home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / env / disclosers.scm < prev    next >
Text File  |  1995-10-13  |  9KB  |  262 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; --------------------
  5. ; DISCLOSE methods
  6.  
  7. (define-method &disclose ((obj :closure))
  8.   (let ((id (template-id (closure-template obj)))
  9.         (name (template-print-name (closure-template obj))))
  10.     (if name
  11.         (list 'procedure
  12.               id
  13.               ;; A heuristic that sometimes loses.
  14. ;                 (if (and (pair? name)
  15. ;                          (eq? (car name) '#t) ;Curried
  16. ;                          (vector? (closure-env obj)))
  17. ;                     (error-form
  18. ;                       (if (null? (cdddr name))
  19. ;                           (caddr name)
  20. ;                           (cdddr name))
  21. ;                       (reverse (cdr (vector->list (closure-env obj)))))
  22. ;                     name)
  23.               name)
  24.         (list 'procedure id))))
  25.  
  26. (define-method &disclose ((obj :template))
  27.   (let ((id (template-id obj))
  28.         (name (template-print-name obj)))
  29.     (if name
  30.         (list 'template id name)
  31.         (list 'template id))))
  32.  
  33. (define-method &disclose ((obj :location))
  34.   (cons 'location
  35.         (cons (location-id obj)
  36.               (let ((name (location-name obj)))
  37.                 (if (and name (not (eq? name (location-id obj))))
  38.                     (list name (location-package-name obj))
  39.                     '())))))
  40.  
  41. (define-method &disclose ((obj :continuation))
  42.   (list 'continuation
  43.         (list 'pc (continuation-pc obj))
  44.         (let ((tem (continuation-template obj)))
  45.           (or (template-print-name tem) (template-id tem)))))
  46.  
  47. (define-method &disclose ((obj :code-vector))
  48.   (list 'code-vector (code-vector-length obj))
  49. ; (cons 'code-vector
  50. ;       (let ((z (code-vector-length obj)))
  51. ;         (do ((i (- z 1) (- i 1))
  52. ;              (l '() (cons (code-vector-ref obj i) l)))
  53. ;             ((< i 0) l))))
  54.   )
  55.  
  56.  
  57. (define (template-print-name tem)
  58.   (make-print-name (template-names tem)))
  59.  
  60. (define (make-print-name names)
  61.   (if (null? names)
  62.       #f
  63.       (let ((name (car names))
  64.             (parent-name (make-print-name (cdr names))))
  65.         (cond (parent-name
  66.                `(,(if name name 'unnamed)
  67.                  in
  68.                  ,@(if (pair? parent-name) parent-name (list parent-name))))
  69.               ((string? name) #f)  ;File name
  70.               (else name)))))
  71.  
  72. (define (template-file-name tem)
  73.   (let loop ((names (template-names tem)))
  74.     (if (null? names)
  75.         #f
  76.         (if (string? (car names))
  77.             (car names)
  78.             (loop (cdr names))))))
  79.  
  80. ; --------------------
  81. ; Location names
  82.  
  83. (define (location-info loc)
  84.   (let ((id (location-id loc)))
  85.     (if (integer? id)
  86.         (table-ref location-info-table id)
  87.         #f)))
  88.  
  89. (define (location-name loc)
  90.   (let ((probe (location-info loc)))
  91.     (if probe
  92.         (car probe)
  93.         #f)))
  94.  
  95. (define (location-package-name loc)
  96.   (let ((probe (location-info loc)))
  97.     (if probe
  98.         (table-ref package-name-table (cdr probe))
  99.         #f)))
  100.  
  101.  
  102. ; --------------------
  103. ; Condition disclosers
  104.  
  105. (define *condition-disclosers* '())
  106.  
  107. (define (define-condition-discloser pred proc)
  108.   (set! *condition-disclosers*
  109.         (cons (cons pred proc) *condition-disclosers*)))
  110.  
  111. (define-method &disclose-condition ((c :pair))
  112.   (let loop ((l *condition-disclosers*))
  113.     (if (null? l)
  114.         (cons (cond ((error? c) 'error)
  115.                     ((warning? c) 'warning)
  116.                     (else (car c)))
  117.               (condition-stuff c))
  118.         (if ((caar l) c)
  119.             ((cdar l) c)
  120.             (loop (cdr l))))))
  121.  
  122. (define-condition-discloser interrupt?
  123.   (lambda (c)
  124.     (list 'interrupt (enumerand->name (cadr c) interrupt))))
  125.         
  126.  
  127. ; Make prettier error messages for exceptions
  128.  
  129. (define-condition-discloser exception?
  130.   (lambda (c)
  131.     (let ((opcode (exception-opcode c))
  132.           (args   (exception-arguments c)))
  133.       ((vector-ref exception-disclosers opcode)
  134.        opcode
  135.        args))))
  136.  
  137. (define exception-disclosers
  138.   (make-vector op-count
  139.                (lambda (opcode args)
  140.                  (list 'error
  141.                        "exception"
  142.                        (let ((name (enumerand->name opcode op)))
  143.                          (if (>= opcode (enum op eq?))
  144.                              (error-form name args)
  145.                              (cons name args)))))))
  146.  
  147. (define (define-exception-discloser opcode discloser)
  148.   (vector-set! exception-disclosers opcode discloser))
  149.  
  150. (let ((disc (lambda (opcode args)
  151.               (let ((loc (car args)))
  152.                 (cons 'error
  153.                       (cons (if (location-defined? loc)
  154.                                 "unassigned variable"
  155.                                 "undefined variable")
  156.                             (cons (or (location-name loc) loc)
  157.                                   (let ((pack
  158.                                          (location-package-name loc)))
  159.                                     (if pack
  160.                                         (list (list 'package pack))
  161.                                         '())))))))))
  162.   (define-exception-discloser (enum op global) disc)
  163.   (define-exception-discloser (enum op set-global!) disc))
  164.  
  165. (let ((disc (lambda (opcode args)
  166.               (let ((proc (car args))
  167.                     (as (cadr args)))
  168.                 (list 'error
  169.                       "wrong number of arguments"
  170.                       (error-form (or (if (closure? proc)
  171.                                           (or (template-print-name
  172.                                                (closure-template proc))
  173.                                               proc)
  174.                                           proc)
  175.                                       proc)
  176.                                   as))))))
  177.   (define-exception-discloser (enum op check-nargs=) disc)
  178.   (define-exception-discloser (enum op check-nargs>=) disc))
  179.  
  180. (define-exception-discloser (enum op call)
  181.   (lambda (opcode args)
  182.     (list 'error
  183.           "attempt to call a non-procedure"
  184.           (map value->expression (cons (car args) (cadr args))))))
  185.  
  186. (define-exception-discloser (enum op values)
  187.   (lambda (opcode args)
  188.     (if (null? (car args))
  189.         (list 'error
  190.               "returning zero values when one is expected"
  191.               '(values))
  192.         (list 'error
  193.               "returning several values when only one is expected"
  194.               (error-form 'values (car args))))))
  195.  
  196. (let ((disc (lambda (opcode args)
  197.               (let ((thing     (car args))
  198.                     (type-byte (cadr args))
  199.                     (offset    (caddr args))
  200.                     (rest      (cdddr args)))
  201.                 (let ((data (assq (enumerand->name type-byte stob)
  202.                                   stob-data)))
  203.                   (list 'error
  204.                         "exception"
  205.                         (error-form ((if (= opcode op/stored-object-ref)
  206.                                          car
  207.                                          cadr)
  208.                                      (list-ref data (+ offset 3)))
  209.                                     (cons thing rest))))))))
  210.   (define-exception-discloser (enum op stored-object-ref) disc)
  211.   (define-exception-discloser (enum op stored-object-set!) disc))
  212.  
  213. (define op/stored-object-ref (enum op stored-object-ref))
  214.  
  215. (let ((disc (lambda (opcode args)
  216.               (let ((type (enumerand->name (car args) stob)))
  217.                 (list 'error
  218.                       "exception"
  219.                       (error-form (string->symbol
  220.                                    ;; Don't simplify this to "make-"  --JAR
  221.                                    (string-append (symbol->string 'make-)
  222.                                                   (symbol->string type)))
  223.                                   (cdr args)))))))
  224.   (define-exception-discloser (enum op make-vector-object) disc))
  225.  
  226. (define (vector-exception-discloser suffix)
  227.   (lambda (opcode args)
  228.     (let ((type (enumerand->name (cadr args) stob)))
  229.       (list 'error
  230.             "exception"
  231.             (error-form (string->symbol
  232.                          (string-append (symbol->string type)
  233.                                         "-"
  234.                                         (symbol->string suffix)))
  235.                         (cons (car args) (cddr args)))))))
  236.  
  237. (define-exception-discloser (enum op stored-object-length)
  238.   (vector-exception-discloser 'length))
  239.  
  240. (define-exception-discloser (enum op stored-object-indexed-ref)
  241.   (vector-exception-discloser 'ref))
  242.  
  243. (define-exception-discloser (enum op stored-object-indexed-set!)
  244.   (vector-exception-discloser 'set!))
  245.  
  246. ; Call-errors should print as (proc 'arg1 'arg2 ...)
  247.  
  248. (define-condition-discloser call-error?
  249.   (lambda (c)
  250.     (list 'error (cadr c) (error-form (caddr c) (cdddr c)))))
  251.  
  252. ; --------------------
  253. ; Utilities
  254.  
  255. (define (error-form proc args)
  256.   (cons proc (map value->expression args)))
  257.  
  258. (define (value->expression obj)
  259.   (if (or (number? obj) (char? obj) (string? obj) (boolean? obj))
  260.       obj
  261.       `',obj))
  262.